home *** CD-ROM | disk | FTP | other *** search
/ Dictionaries & Language / Dictionaries and Language (Chestnut CD-ROM) (1993).iso / misc / vb30 / vbdirdos.inc < prev    next >
Encoding:
Text File  |  1986-02-07  |  4.3 KB  |  152 lines
  1.  
  2. {************************************************************************}
  3. {*                                                                      *}
  4. {*                      VB Directory Routines                           *}
  5. {*                                                                      *}
  6. {*                     *** MS-DOS  version ***                          *}
  7. {*                                                                      *}
  8. {*          SetDTA             FindFirst             FindNext           *}
  9. {*                             DirWordList                              *}
  10. {*                                                                      *}
  11. {************************************************************************}
  12.  
  13.  
  14.  
  15. const
  16.    Carry     = 1;
  17.  
  18. type
  19.    DirRec    = record
  20.                  Filler    : array[1..30] Of byte;
  21.                  FName     : array[1..10] Of char;
  22.                end;
  23.    DOSRegs   = record
  24.                  Ax, Bx, Cx, Dx, Bp, Si, Di, Ds, Es, Flags : integer;
  25.                end;
  26.  
  27.  
  28.   procedure SetDTA(var DMAbuf);
  29.   { set the data transfer area address }
  30.     var
  31.       DirReg    : DOSregs;
  32.     begin
  33.       DirReg.Ax := $1A00;
  34.       DirReg.Ds := SEG(DMAbuf);
  35.       DirReg.Dx := OFS(DMAbuf);
  36.       MsDos(DirReg);
  37.     end;
  38.  
  39.  
  40.   function FindFirst(Pattern: AnyString; var First: DirRec): integer;
  41.   { search for first file match }
  42.     var
  43.       DirReg    : DOSRegs;
  44.     begin
  45.       SetDTA(First);
  46.       Pattern := Pattern + chr(0);
  47.       DirReg.Ds := SEG(Pattern[1]);
  48.       DirReg.Dx := OFS(Pattern[1]);
  49.       DirReg.Ax := $4E00;
  50.       DirReg.Cx := $FF;
  51.       MsDos(DirReg);
  52.       if (Carry and DirReg.Flags ) = 0
  53.         then
  54.           FindFirst := 0
  55.         else
  56.           FindFirst := DirReg.Ax;
  57.     end;
  58.  
  59.  
  60.   function FindNext(var Next: DirRec) : integer;
  61.   { search for subsequent file matches }
  62.     var
  63.       DirReg : DOSRegs;
  64.     begin
  65.       SetDTA(Next);
  66.       DirReg.Ax := $4F00;
  67.       MsDos(DirReg);
  68.       if (Carry and DirReg.Flags ) = 0
  69.         then
  70.           FindNext := 0
  71.         else
  72.           FindNext := DirReg.Ax;
  73.     end;
  74.  
  75.  
  76.   procedure DirWordList;
  77.   { derive and print a directory of word list files }
  78.     var
  79.       DirNames        : array[1..50] of ListName;
  80.       Mask            : AnyString;
  81.       FileName        : DirRec;
  82.       FileCount       : integer;
  83.       i, j, Iok       : integer;
  84.  
  85.     procedure Transfer(F: DirRec);
  86.     { transfer a file name char array to a string }
  87.       var
  88.         DirName : string[9];
  89.         k       : integer;
  90.       begin
  91.         k := 1;
  92.         while (F.FName[k] <> '.') and (k <= 9) do
  93.           begin
  94.             DirName[k] := F.FName[k];
  95.             k := succ(k)
  96.           end;
  97.         DirName[0] := chr(k-1);
  98.         DirNames[FileCount] := copy(DirName,1,length(DirName))
  99.       end;
  100.  
  101.     begin { DirWordList }
  102.       Mask := '????????.' + Extent;
  103.       FileCount := 0;
  104.       Iok := FindFirst(Mask,FileName);
  105.       if Iok = 0
  106.         then
  107.           begin
  108.             FileCount := succ(FileCount);
  109.             Transfer(FileName)
  110.           end;
  111.       while Iok = 0 do
  112.         begin
  113.           Iok := FindNext(FileName);
  114.           if Iok = 0
  115.             then
  116.               begin
  117.                 FileCount := succ(FileCount);
  118.                 Transfer(FileName)
  119.               end
  120.         end;
  121.       i := 1;
  122.       writeln;
  123.       repeat
  124.         for j := 1 to 20 do
  125.           write (' ');
  126.         write (DirNames[i]);
  127.         if (8 - length(DirNames[i]))  > 0
  128.           then
  129.             for j := 1 to (8 - length(Dirnames[i])) do
  130.               write (' ');
  131.         write ('  |  ');
  132.         i := succ(i);
  133.         if i <= FileCount
  134.           then
  135.             begin
  136.               write (DirNames[i]);
  137.               if (8 - length(DirNames[i])) > 0
  138.                 then
  139.                   for j := 1 to (8 - length(Dirnames[i])) do
  140.                     write (' ');
  141.               write ('  |  ')
  142.             end;
  143.         i := succ(i);
  144.         if i <= FileCount
  145.           then
  146.             writeln (DirNames[i]);
  147.         i := succ(i)
  148.       until i > FileCount;
  149.       writeln
  150.     end;
  151.  
  152.